home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp.lbr / XLLIST.CQ / xllist.c
Encoding:
C/C++ Source or Header  |  1985-06-03  |  11.6 KB  |  496 lines
  1.                    /* xllist - xlisp list builtin functions */
  2.  
  3. #ifdef CI_86
  4. #include "a:stdio.h"
  5. #include "xlisp.h"
  6. #endif
  7.  
  8. #ifdef AZTEC
  9. #include "a:stdio.h"
  10. #include "xlisp.h"
  11. #endif
  12.  
  13. #ifdef unix
  14. #include <stdio.h>
  15. #include <xlisp.h>
  16. #endif
  17.  
  18.  
  19.                             /* external variables */
  20.  
  21. extern struct node *xlstack;
  22.  
  23.  
  24.                               /* local variables */
  25.  
  26. static struct node *t;
  27. static struct node *a_subr;
  28. static struct node *a_list;
  29. static struct node *a_sym;
  30. static struct node *a_int;
  31. static struct node *a_str;
  32. static struct node *a_obj;
  33. static struct node *a_fptr;
  34. static struct node *a_kmap;
  35.  
  36.  
  37.                        /**********************************
  38.                        *  xlist - builtin function list  *
  39.                        **********************************/
  40.  
  41. static struct node *xlist(args)
  42.   struct node *args;
  43. {
  44.     struct node *oldstk,arg,list,val,*last,*lptr;
  45.  
  46.     oldstk = xlsave(&arg,&list,&val,NULL);
  47.     arg.n_ptr = args;
  48.  
  49.     for (last = NULL; arg.n_ptr != NULL; last = lptr)
  50.     {
  51.         val.n_ptr = xlevarg(&arg.n_ptr);
  52.         lptr = newnode(LIST);
  53.         if (last == NULL)
  54.             list.n_ptr = lptr;
  55.         else
  56.             last->n_listnext = lptr;
  57.         lptr->n_listvalue = val.n_ptr;
  58.     }
  59.  
  60.     xlstack = oldstk;
  61.     return (list.n_ptr);
  62. }
  63.  
  64.  
  65.                        /*********************************
  66.                        *  cond - builtin function cond  *
  67.                        *********************************/
  68.  
  69. static struct node *cond(args)
  70.   struct node *args;
  71. {
  72.     struct node *oldstk,arg,list,*val;
  73.  
  74.     oldstk = xlsave(&arg,&list,NULL);
  75.     arg.n_ptr = args;
  76.  
  77.     val = NULL;
  78.     while (arg.n_ptr != NULL)
  79.     {
  80.         list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  81.         if (xlevarg(&list.n_ptr) != NULL)
  82.         {
  83.             while (list.n_ptr != NULL)
  84.                 val = xlevarg(&list.n_ptr);
  85.             break;
  86.         }
  87.     }
  88.  
  89.     xlstack = oldstk;
  90.     return (val);
  91. }
  92.  
  93.  
  94.                           /****************************
  95.                           *  atom - is this an atom?  *
  96.                           ****************************/
  97.  
  98. static struct node *atom(args)
  99.   struct node *args;
  100. {
  101.     struct node *arg;
  102.  
  103.     if ((arg = xlevarg(&args)) == NULL || arg->n_type != LIST)
  104.         return (t);
  105.     else
  106.         return (NULL);
  107. }
  108.  
  109.  
  110.                            /*************************
  111.                            *  null - is this null?  *
  112.                            *************************/
  113.  
  114. static struct node *null(args)
  115.   struct node *args;
  116. {
  117.     if (xlevarg(&args) == NULL)
  118.         return (t);
  119.     else
  120.         return (NULL);
  121. }
  122.  
  123.  
  124.                        /**********************************
  125.                        *  type - return type of a thing  *
  126.                        **********************************/
  127.  
  128. static struct node *type(args)
  129.     struct node *args;
  130. {
  131.     struct node *arg;
  132.  
  133.     if (!(arg = xlevarg(&args)))
  134.         return (NULL);
  135.  
  136.     switch (arg->n_type)
  137.     {
  138.         case SUBR: return (a_subr);
  139.  
  140.         case LIST: return (a_list);
  141.  
  142.         case SYM: return (a_sym);
  143.  
  144.         case INT: return (a_int);
  145.  
  146.         case STR: return (a_str);
  147.  
  148.         case OBJ: return (a_obj);
  149.  
  150.         case FPTR: return (a_fptr);
  151.  
  152.         case KMAP: return (a_kmap);
  153.  
  154.         default: xlfail("Bad node.");
  155.  
  156.         }
  157. }
  158.  
  159.  
  160.                           /****************************
  161.                           *  listp - is this a list?  *
  162.                           ****************************/
  163.  
  164. static struct node *listp(args)
  165.   struct node *args;
  166. {
  167.     if (xlistp(xlevarg(&args)))
  168.         return (t);
  169.     else
  170.         return (NULL);
  171. }
  172.  
  173.  
  174.                      /*************************************
  175.                      *  xlistp - internal listp function  *
  176.                      *************************************/
  177.  
  178. static int xlistp(arg)
  179.   struct node *arg;
  180. {
  181.     return (arg == NULL || arg->n_type == LIST);
  182. }
  183.  
  184.  
  185.                            /**************************
  186.                            *  eq - are these equal?  *
  187.                            **************************/
  188.  
  189. static struct node *eq(args)
  190.   struct node *args;
  191. {
  192.     struct node *oldstk,arg,arg1,arg2,*val;
  193.  
  194.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  195.     arg.n_ptr = args;
  196.  
  197.     arg1.n_ptr = xlevarg(&arg.n_ptr);
  198.     arg2.n_ptr = xlevarg(&arg.n_ptr);
  199.     xllastarg(arg.n_ptr);
  200.  
  201.     if (xeq(arg1.n_ptr,arg2.n_ptr))
  202.         val = t;
  203.     else
  204.         val = NULL;
  205.  
  206.     xlstack = oldstk;
  207.     return (val);
  208. }
  209.  
  210.  
  211.                         /*******************************
  212.                         *  xeq - internal eq function  *
  213.                         *******************************/
  214.  
  215. static int xeq(arg1,arg2)
  216.   struct node *arg1,*arg2;
  217. {
  218.     if (arg1 != NULL && arg1->n_type == INT &&
  219.         arg2 != NULL && arg2->n_type == INT)
  220.         return (arg1->n_int == arg2->n_int);
  221.     else
  222.         return (arg1 == arg2);
  223. }
  224.  
  225.  
  226.                          /*****************************
  227.                          *  equal - are these equal?  *
  228.                          *****************************/
  229.  
  230. static struct node *equal(args)
  231.   struct node *args;
  232. {
  233.     struct node *oldstk,arg,arg1,arg2,*val;
  234.  
  235.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  236.     arg.n_ptr = args;
  237.  
  238.     arg1.n_ptr = xlevarg(&arg.n_ptr);
  239.     arg2.n_ptr = xlevarg(&arg.n_ptr);
  240.     xllastarg(arg.n_ptr);
  241.  
  242.     if (xequal(arg1.n_ptr,arg2.n_ptr))
  243.         val = t;
  244.     else
  245.         val = NULL;
  246.  
  247.     xlstack = oldstk;
  248.     return (val);
  249. }
  250.  
  251.  
  252.                      /*************************************
  253.                      *  xequal - internal equal function  *
  254.                      *************************************/
  255.  
  256. static int xequal(arg1,arg2)
  257.   struct node *arg1,*arg2;
  258. {
  259.     if (xeq(arg1,arg2))
  260.         return (TRUE);
  261.     else
  262.     if (xlistp(arg1) && xlistp(arg2))
  263.         return (xequal(arg1->n_listvalue,arg2->n_listvalue) &&
  264.                 xequal(arg1->n_listnext, arg2->n_listnext));
  265.     else
  266.         return (FALSE);
  267. }
  268.  
  269.  
  270.                      /*************************************
  271.                      *  head - return the head of a list  *
  272.                      *************************************/
  273.  
  274. static struct node *head(args)
  275.   struct node *args;
  276. {
  277.     struct node *list;
  278.  
  279.     if ((list = xlevmatch(LIST,&args)) == NULL)
  280.         xlfail("null list");
  281.  
  282.     xllastarg(args);
  283.  
  284.     return (list->n_listvalue);
  285. }
  286.  
  287.  
  288.                      /*************************************
  289.                      *  tail - return the tail of a list  *
  290.                      *************************************/
  291.  
  292. static struct node *tail(args)
  293.   struct node *args;
  294. {
  295.     struct node *list;
  296.  
  297.     if ((list = xlevmatch(LIST,&args)) == NULL)
  298.         xlfail("null list");
  299.  
  300.     xllastarg(args);
  301.  
  302.     return (list->n_listnext);
  303. }
  304.  
  305.  
  306.                   /*******************************************
  307.                   *  nth - return the nth element of a list  *
  308.                   *******************************************/
  309.  
  310. static struct node *nth(args)
  311.   struct node *args;
  312. {
  313.     struct node *oldstk,arg,list;
  314.     int n;
  315.  
  316.     oldstk = xlsave(&arg,&list,NULL);
  317.     arg.n_ptr = args;
  318.  
  319.     if ((n = xlevmatch(INT,&arg.n_ptr)->n_int) < 1)
  320.         xlfail("invalid argument");
  321.  
  322.     if ((list.n_ptr = xlevmatch(LIST,&arg.n_ptr)) == NULL)
  323.         xlfail("invalid argument");
  324.  
  325.     xllastarg(arg.n_ptr);
  326.  
  327.     for (; n > 1; n--)
  328.     {
  329.         list.n_ptr = list.n_ptr->n_listnext;
  330.         if (list.n_ptr == NULL || list.n_ptr->n_type != LIST)
  331.             xlfail("invalid argument");
  332.     }
  333.  
  334.     xlstack = oldstk;
  335.     return (list.n_ptr->n_listvalue);
  336. }
  337.  
  338.  
  339.                    /*****************************************
  340.                    *  length - return the length of a list  *
  341.                    *****************************************/
  342.  
  343. static struct node *length(args)
  344.   struct node *args;
  345. {
  346.     struct node *oldstk,list,*val;
  347.     int n;
  348.  
  349.     oldstk = xlsave(&list,NULL);
  350.  
  351.     list.n_ptr = xlevmatch(LIST,&args);
  352.     xllastarg(args);
  353.  
  354.     for (n = 0; list.n_ptr != NULL; n++)
  355.         list.n_ptr = list.n_ptr->n_listnext;
  356.  
  357.     xlstack = oldstk;
  358.  
  359.     val = newnode(INT);
  360.     val->n_int = n;
  361.     return (val);
  362. }
  363.  
  364.  
  365.                      /*************************************
  366.                      *  append - builtin function append  *
  367.                      *************************************/
  368.  
  369. static struct node *append(args)
  370.   struct node *args;
  371. {
  372.     struct node *oldstk,arg,list,last,val,*lptr;
  373.  
  374.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  375.     arg.n_ptr = args;
  376.  
  377.     while (arg.n_ptr != NULL)
  378.     {
  379.         list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
  380.         while (list.n_ptr != NULL && list.n_ptr->n_type == LIST)
  381.         {
  382.             lptr = newnode(LIST);
  383.             if (last.n_ptr == NULL)
  384.                 val.n_ptr = lptr;
  385.             else
  386.                 last.n_ptr->n_listnext = lptr;
  387.             lptr->n_listvalue = list.n_ptr->n_listvalue;
  388.             last.n_ptr = lptr;
  389.             list.n_ptr = list.n_ptr->n_listnext;
  390.         }
  391.  
  392.         if (list.n_ptr != NULL)
  393.             xlfail("bad list");
  394.     }
  395.  
  396.     xlstack = oldstk;
  397.     return (val.n_ptr);
  398. }
  399.  
  400.  
  401.                     /***************************************
  402.                     *  reverse - builtin function reverse  *
  403.                     ***************************************/
  404.  
  405. static struct node *reverse(args)
  406.   struct node *args;
  407. {
  408.     struct node *oldstk,list,val,*lptr;
  409.  
  410.     oldstk = xlsave(&list,&val,NULL);
  411.  
  412.     list.n_ptr = xlevmatch(LIST,&args);
  413.     xllastarg(args);
  414.  
  415.     while (list.n_ptr != NULL && list.n_ptr->n_type == LIST)
  416.     {
  417.         lptr = newnode(LIST);
  418.         lptr->n_listvalue = list.n_ptr->n_listvalue;
  419.         lptr->n_listnext = val.n_ptr;
  420.         val.n_ptr = lptr;
  421.  
  422.         list.n_ptr = list.n_ptr->n_listnext;
  423.     }
  424.  
  425.     if (list.n_ptr != NULL)
  426.         xlfail("bad list");
  427.  
  428.     xlstack = oldstk;
  429.     return (val.n_ptr);
  430. }
  431.  
  432.  
  433.                      /*************************************
  434.                      *  cons - construct a new list cell  *
  435.                      *************************************/
  436.  
  437. static struct node *cons(args)
  438.   struct node *args;
  439. {
  440.     struct node *oldstk,arg,arg1,arg2,*lptr;
  441.  
  442.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  443.     arg.n_ptr = args;
  444.  
  445.     arg1.n_ptr = xlevarg(&arg.n_ptr);
  446.     arg2.n_ptr = xlevarg(&arg.n_ptr);
  447.     xllastarg(arg.n_ptr);
  448.  
  449.     lptr = newnode(LIST);
  450.     lptr->n_listvalue = arg1.n_ptr;
  451.     lptr->n_listnext  = arg2.n_ptr;
  452.  
  453.     xlstack = oldstk;
  454.     return (lptr);
  455. }
  456.  
  457.  
  458.                 /************************************************
  459.                 *  xllinit - xlisp list initialization routine  *
  460.                 ************************************************/
  461.  
  462. xllinit()
  463. {
  464.     /* define some symbols */
  465.     t = xlenter("t");
  466.     a_subr = xlenter("SUBR");
  467.     a_list = xlenter("LIST");
  468.     a_sym = xlenter("SYM");
  469.     a_int = xlenter("INT");
  470.     a_str = xlenter("STR");
  471.     a_obj = xlenter("OBJ");
  472.     a_fptr = xlenter("FPTR");
  473.     a_kmap = xlenter("KMAP");
  474.  
  475.     /* functions with reasonable names */
  476.     xlsubr("head",head);
  477.     xlsubr("tail",tail);
  478.     xlsubr("nth",nth);
  479.  
  480.     /* real lisp functions */
  481.     xlsubr("atom",atom);
  482.     xlsubr("eq",eq);
  483.     xlsubr("equal",equal);
  484.     xlsubr("null",null);
  485.     xlsubr("type",type);
  486.     xlsubr("listp",listp);
  487.     xlsubr("cond",cond);
  488.     xlsubr("list",xlist);
  489.     xlsubr("cons",cons);
  490.     xlsubr("car",head);
  491.     xlsubr("cdr",tail);
  492.     xlsubr("append",append);
  493.     xlsubr("reverse",reverse);
  494.     xlsubr("length",length);
  495. }
  496.